# munch.tcl - utility to munch C++ modules for static constructors.
#
# Copyright 1994-1998 Wind River Systems, Inc.
#
# modification history
# -----------------------
# 01h,13apr99,sn   deduce prepends-underscore from arch
# 01g,24mar99,sn   ensure that ctors, dtors data is 4 byte aligned
# 01f,24mar99,sn   corrected indentation: no code changes
# 01e,16mar99,sn   removed references to VOIDFUNCPTR (fixes SPR 25469)
# 01d,11mar99,sn   fixed typo that stopped -asm from having any effect
# 01c,22feb99,sn   rewrote to include postMunch.tcl
#                  produce __asm__ directives if -asm specified
# 01b,01may98,sn   fixed definition of procSmbl
# 01a,24feb98,jco  written, tcl translation of munch.cpp.
#
# DESCRIPTION
# This script is intended to be lauched from munch.sh on Unix and munch.bat
# on Windows. See documentation in munch.sh (hutils).
#

###############################################################################
# 
# prologEmit - Emit prologue in specified language
# 
# $lang must be C or ASM

proc prologEmit {lang} {
    ${lang}PrologEmit
}

###############################################################################
# 
# CPrologEmit - Emit prologue in C
#
proc CPrologEmit {} {
    puts "/* ctors and dtors arrays -- to be used by runtime system */"
    puts "/*   to call static constructors and destructors          */"
    puts "/*                                                        */"
    puts "/* NOTE: Use a C compiler to compile this file. If you    */"
    puts "/*       are using GNU C++, be sure to use compile this   */"
    puts "/*       file using a GNU compiler with the               */"
    puts "/*       -fdollars-in-identifiers flag.                   */"
    puts ""
}

###############################################################################
# 
# ASMPrologEmit - emit prologue as ASM directives
#

proc ASMPrologEmit {} {
    puts "/* ctors and dtors arrays -- to be used by runtime system */"
    puts "/*   to call static constructors and destructors          */"
    puts "/*                                                        */"
    puts "/* NOTE: Use a GNU C/C++ compiler to compile this file.   */"
    puts ""
    puts "__asm__ (\".data\");"
    }

###############################################################################
# 
# arrayEmit - emit an array in the specified language and order
# 
# $lang must be C or ASM
# $op is the C name of the array minus an obligatory leading underscore
# $order is "forward" or "reverse"
# $procList is the list of function pointers to put in the array

proc arrayEmit {lang op order procList} {
    listRemoveLeftDuplicates $procList outList
    if {$order == "reverse"} {
	listReverse $outList outList
	}
    ${lang}ArrayEmit $op $outList
}

###############################################################################
# 
# CarrayEmit - Emit array in C
#
# $op is the C name of the array minus an obligatory leading underscore
# $procList is the list of function pointers to put in the array

proc CArrayEmit {op procList} {
    # Declare each function in procList
    foreach pn $procList {
	# Remove possible compiler prefixed leading underscore
	regsub "^__" $pn "_" pn
	puts "\nvoid $pn\(\);"
    }
    # Declare an array named $op
    puts "\nextern void (*_$op\[\])();"
    puts "void (*_$op\[\])() =\n    {"
    # Print the elements of the array
    foreach pn $procList {
	# Remove possible compiler prefixed leading underscore
	regsub "^__" $pn "_" pn
	puts "    $pn,"
    }
    # End the array with a null
    puts "    0\n    };"
}

###############################################################################
# 
# ASMArrayEmit - Emit array as ASM directives
#
# $op is the C name of the array minus an obligatory leading underscore
# $procList is the list of function pointers to put in the array

proc ASMArrayEmit {op procList} {
    # underscore is "_" if the compiler prepends an underscore
    global underscore
    global omf
    # Declare an array named $op
    puts "__asm__ (\".global ${underscore}_${op}\");"
    # Make sure the label is 4 bytes aligned
    puts "__asm__ (\".align 4\");"
    puts "__asm__ (\"${underscore}_${op}:\");"
    # Print the elements of the array
    foreach pn $procList {
	${omf}FunctionPtrEmit $pn
    }
    # End the array with a null
    puts "__asm__ (\"    .long 0\");"
}

###############################################################################
# 
# SOMFunctionPtrEmit - print inline assembly for a function pointer
#                      appropriate for the SIMHP assembler.
#
proc SOMFunctionPtrEmit {pn} {
    puts "__asm__ (\"    .IMPORT ${pn},CODE\");"
    puts "__asm__ (\"    .word P%${pn}\");"
}

###############################################################################
# 
# FunctionPtrEmit - print inline assembly for a function pointer
#                   appropriate for a general assembler.
#
proc FunctionPtrEmit {pn} {
    puts "__asm__ (\"    .long ${pn}\");"
}

###############################################################################
# 
# deduceUnderscore - returns "_" if the compiler prepends an underscore
#

proc deduceUnderscore {arch} {
    # for the moment we default to prepending an underscore
    global underscore
    case $arch in {
	{ppc | simso | mips | hppa} {set underscore ""}
	default {set underscore "_"}
    }	
}

###############################################################################
# 
# listReverse - reverse a list
#
# Reverse $list and put the result in the variable named $name.
#

proc listReverse {inList name} {
    upvar $name outputList
    set outputList ""
    set index [llength $inList]
    while {$index != 0} {
        incr index -1
        lappend outputList [lindex $inList $index]
    }
}


###############################################################################
# 
# listRemoveLeftDuplicates - remove left duplicates from a list
#
# Without changing the order remove all but the rightmost copy of each 
# element of $inList and put the result in the variable $name.
#

proc listRemoveLeftDuplicates {inList name} {
    upvar $name outList
    listReverse $inList reversedInList
    set maxIndex [expr [llength $inList] - 1]
    set outList ""
    # Traverse list removing all but the rightmost copy of each element
    set index 0
    foreach el $inList {
        # The leftmost occurence of this element in the reversed list ...
        set reverseRightIndex [lsearch -exact $reversedInList $el] 
        # is the rightmost occurence in the original list
        set rightIndex [expr $maxIndex - $reverseRightIndex]
        if {$index == $rightIndex} {
            lappend outList $el
	}
        incr index
        }
}


###############################################################################
#
# inputProcess - Scan the input and extract ctors/dtors
# 
proc inputProcess {} {
    # Each entry is the assembler name of a ctor or a dtor
    global ctorList dtorList
    set ctorList {}
    set dtorList {}

    # define tags to detect, respectively for cfront, diab and gnu compilers
    set ctorTags {"^___?sti__" "^___?STI__" "^__?GLOBAL_.I."}
    set dtorTags {"^___?std__" "^___?STD__" "^__?GLOBAL_.D."}

    # scan special tags in standard input 
    while {![eof stdin]} {
	# read one line
	gets stdin line
	
	# extract the procedure symbol (last position in list)
	set procSmbl [lindex [lrange $line end end] 0]
	
	# look for special tags, and populate ctorList and dtorList
	if {$procSmbl != ""} {
            # ctors
	    foreach ctag $ctorTags {
		if [regexp $ctag $procSmbl] {
		    lappend ctorList $procSmbl
		}
	    }
            # dtors
	    foreach dtag $dtorTags {
		if [regexp $dtag $procSmbl] {
		    lappend dtorList $procSmbl
		}
	    }
	}
    }
}

###############################################################################
#
# Main Section
#

# Process command line options

set lang "C"

if {[lindex $argv 0] == "-asm" } {
    set lang "ASM"
    set arch [lindex $argv 1]
}

# omf is SOM (SIMHP) or ""

set omf ""

if {$lang == "ASM"} {
    case $arch in {
	"hppa" {set omf "SOM"}
    }
    deduceUnderscore $arch
}

# Scan input stream

inputProcess

# Emit prologue
prologEmit $lang

# Emit array of initializers
arrayEmit $lang ctors forward $ctorList
	
# Emit array of finalizers in reverse
arrayEmit $lang dtors reverse $dtorList
